{
module PHaskellParser where
import PHaskellTypes
import Char

parseError :: [Token] -> a
parseError t  = error ("Parse error -> " ++ (show t))
				 


data Token
      = TokenInt String
      | TokenVar String
      | TokenBool String
      | TokenBinOp 
      | TokenEq
      | TokenPlus
      | TokenMinus
      | TokenTimes
      | TokenDiv
      | TokenOB
      | TokenCB
	  | TokenMin
	  | TokenMaj
	  | TokenMineq
	  | TokenMajeq
	  | TokenLEq
	  | TokenSep
	  | TokenData
	  | TokenTypeDef
	  | TokenArrow
	  | TokenRArrow
	  | TokenTypeBool
	  | TokenTypeInt
	  | TokenMod
	  | TokenNotEq
	  | TokenNot
	  | TokenWhere
	  | TokenEnd
	  | TokenBackSlach
	  | TokenIf
	  | TokenThen
	  | TokenElse
	  | TokenGuard
 	  | TokenOtherwise
 	  | TokenOpenList
      | TokenCloseList
      | TokenListConstructor
      | TokenComma 
      | TokenUnknown
	  | TokenOr
	  | TokenAnd
	  | TokenLogirAnd
	  | TokenLogirXor
	  | TokenAccess   
	  | TokenIfCexp   
	  | TokenDot   
	  | TokenOpenB   
	  | TokenCloseB  
	  | TokenArroba
	  | TokenShiftLeft
	  | TokenShiftRight
	  | TokenString String
	  | TokenLNot
	  | TokenArrow2
	  | TokenSizeOf
 deriving Show 
}

%name parser
%tokentype { Token }
%error { parseError }



%token
	int   { TokenInt $$ }
	var   { TokenVar $$ }
	binop { TokenBinOp }
	bool  { TokenBool $$ }
	string  {TokenString $$}
	'::' { TokenTypeDef }
	arrow {TokenArrow}
	arrow2 {TokenArrow2}
	rarrow {TokenRArrow}
	typebool {TokenTypeBool}
	typeint  {TokenTypeInt}		
	not { TokenNot }
	';' { TokenSep }
	'=' { TokenEq }
	'+' { TokenPlus }
	'-' { TokenMinus }
	'*' { TokenTimes }
	'/' { TokenDiv }
	'(' { TokenOB }
	')' { TokenCB }
	'<' { TokenMin}
	'>' { TokenMaj}
	'<=' { TokenMineq}
	'>=' { TokenMajeq}
	'==' { TokenLEq}
	'%'  { TokenMod}
	'!=' { TokenNotEq }
	'where' { TokenWhere }
	'end'  {TokenEnd}
	'\\'    {TokenBackSlach}
    'if'     {TokenIf}
    'then'   {TokenThen}
    'else'   {TokenElse}
    '|'      {TokenGuard}
    'otherwise' {TokenOtherwise}
    'data'    { TokenData}
    '['       { TokenOpenList}
    ']'       { TokenCloseList}
    ':'       { TokenListConstructor }
    ','       { TokenComma }
	'||'      { TokenOr    }
	'&&'      { TokenAnd   }
	'?'       { TokenIfCexp   }
	'.'       { TokenDot   }
	'{'       { TokenOpenB   }
	'}'       { TokenCloseB   }
	'@'       { TokenArroba}
	'&'       { TokenLogirAnd}
	'^'       { TokenLogirXor}
	'<<' 	  {TokenShiftLeft}
	'>>'  	  {TokenShiftRight}
	'~'	      {TokenLNot}
	sizeof    {TokenSizeOf}
	
	 
	   
%left arrow2	  
%left arrow
%left rarrow
%right ':'
%left '='
%left ';'
%right 'where' 'end' '|'
%left ',' 
%left '.' APPLICATION Exp
%right 'then'
%nonassoc '<' '>' '<=' '>=' binop 'if'
%right 'else'  
%right '==' '!=' 
%left '+' '-' 
%left '*' '/' '%'
%left NEG not
%left int var bool '(' ')'
%nonassoc FUNCCALL
%left '::'
%nonassoc TEMPLATE
%nonassoc  '[' ']'
 



%%
Program:   SuperCombinator  Program { $1:$2 } 
          | ';' Program             {  $2  }
          | {-empty-}               {  []  }



SuperCombinator: TypeDefinition                               { $1 }
                | 'data' var '=' TypesConstructorList   	  { UserTypeDefinition $2 $4 }
                | var ExpList '=' Exp    'where' Program 'end' { FunctionDefinitionSc $1 $2 $4 $6 }
                | var ExpList GuardList  'where' Program 'end' { FunctionDefinitionSc $1 $2 ( expandGuard $3) $5 }
                | var ExpList '=' Exp                         { FunctionDefinitionSc $1 $2 $4 [] }
                | var ExpList GuardList                       { FunctionDefinitionSc $1 $2 ( expandGuard $3) [] }
                | Generatrix                              	  { GeneratrixTunneling $1 }                
                                  
TypesConstructorList:   TypesConstructor                             { [$1]  }
                      | TypesConstructor '|' TypesConstructorList    { $1:$3}

TypesConstructor:  var TypeList  { ConstructorType $1 $2 }
            

TypeList:  {- Empty -}      {  []  }
          | Type TypeList   { $1:$2}


GuardList:   Guard   GuardList    { $1:$2}
           | Guard               { [$1]}
               
Guard:       '|' Exp '=' Exp           {($2,$4)}
           | '|' 'otherwise' '=' Exp   {(Boolean "true" ,$4)}
              
TypeDefinition: var '::' Type         { TypeDefinitionSc ($1, $3)}

Type:  typebool        { Bool }
     | typeint         { Int }
     | Type arrow Type { Arrow $1 $3}
     | var             { UserDef $1 }
     | '(' Type ')'    { $2 }		

Exp : 
       Exp '+' Exp { App (App (Variable "pAdd") $1) $3 }
	 | Exp '-' Exp { App (App (Variable "pMinus") $1) $3 }
	 | Exp '*' Exp { App (App (Variable "pPlus") $1) $3  }
	 | Exp '/' Exp { App (App (Variable "pDiv") $1) $3  }
	 | Exp '<'  Exp  { App (App (Variable "pLess") $1) $3 }
     | Exp '<=' Exp  { App (App (Variable "pLessEq") $1) $3 }
	 | Exp '>'  Exp  { App (App (Variable "pGreat") $1) $3 }
	 | Exp '>=' Exp  { App (App (Variable "pGreatEq") $1) $3 }
	 | Exp '==' Exp  { App (App (Variable "pEq") $1) $3 }
	 | Exp '||' Exp  { App (App (Variable "pOr") $1) $3 }
	 | Exp '&&' Exp  { App (App (Variable "pAnd") $1) $3 }
	 | Exp '%' Exp { App (App (Variable "pMod") $1) $3 }
	 | Exp '!=' Exp {  App (App (Variable "pNotEq") $1) $3 }
	 | Exp binop var binop Exp { App (App (Variable $3) $1) $5 }
	 | not Exp            { App (Variable "pNot") $2 }
	 | '-' Exp %prec NEG  { App (Variable "pNeg") $2 }
	 | '+' Exp %prec NEG { App (Variable "pAdd") $2   }
	 | '*' Exp %prec NEG { App (Variable "pPlus") $2  }
	 | '/' Exp %prec NEG { App (Variable "pDiv") $2   }
	 | sizeof Exp        { App (Variable "pSizeOf") $2   }
	 | '\\' Exp '::' Type arrow Exp  	{ Lambda $2 $4 $6 }
	 | 'if' Exp 'then' Exp 'end'           { IfOnly $2 $4 }
	 | 'if' Exp 'then' Exp 'else' Exp      { If $2 $4 $6 }
	 | Exp ':' Exp                         { App (App (Variable "metalist") $1) $3 }
	 | Exp AExp                            { App $1 $2} 
	 | AExp                                { $1 }
	 
	
AExp: '(' Exp ')'   { $2 }
     | '[' ']'                             { Variable "metaemptylist" }
	 | '[' ComaExpList ']'                 { makeApplicaionFromList $2 }
	 | int          { Integer $1 }
	 | bool         { Boolean $1 }
	 | var          { Variable $1 }

	
	   
ExpList: {-empty -}    { []  }
        | AExp ExpList  { $1:$2}               
   
ComaExpList:  AExp                  { [ $1 ] }
            | AExp ',' ComaExpList  { $1:$3  }
           




-- ========================================= Genetratices =====================================

--completar operadores, y precedencia

Generatrix: '{' CTypeList '}' var  ExpList '{' CArgList '}' '=' SepList CodeExp   { Generatrix $2 $4 $5  (filter (/=NoCArg) $7) $11 }


--Falta soportar tipos mas completos
CArgList:  CArgument ',' CArgList   { $1:$3}  
          |CArgument                { [$1] } 
          |{-empty -}           {  []  }

CArgument: CTypeList { makeCargs $1 }


SepList:  ';' SepList         { $1:$2}  
         | ';'                { [$1] }
         |{-empty -}           {  []  }  

CTypeList: BasicType CTypeList   { $1:$2}  
         | BasicType            { [$1] }
         |{-empty -}           {  []  }  

BasicType:  var      { $1 }
          | var '*'  { $1++"*" }
          | var '&'  { $1++"&" }
          | typeint  {"int"}
          | typeint '*' {"int*"}
          | typeint '&' {"int&"}
          | typebool {"bool"}



CodeExp:'(' CodeExp ')'						       {CodeParent $2 }
        | int             						   {CodeNumber $1 }
	 	| bool						               {CodeBoolean $1 }
	 	| var          						       {CodeVariable $1 }
	 	| string								   {CodeString $1 }
	 	| '{' var HaskellExpList '}' '(' CodeExpList ')'   {CodeGeneratrixCall $2 $3 $6  }
	 	| CodeExp '['  CodeExp ']'        %prec FUNCCALL   {CodeArraySubscript $1 $3}
	    | CodeExp '('  CodeExpList ')'    %prec FUNCCALL   {CodeFunctionCall  $1 $3}
	    | CodeExp '<'  CodeExpList '>'    %prec TEMPLATE   {CodeTemplateInst  $1 $3}
	 	| CodeExp '*' CodeExp 				{CodeBinaryOpMult $1 $3 }
	 	| CodeExp '/' CodeExp 				{CodeBinaryOpDiv $1 $3 }
	 	| CodeExp '+' CodeExp 				{CodeBinaryOpAdd $1 $3 }
	 	| CodeExp '-' CodeExp 				{CodeBinaryOpMinus $1 $3 }
	 	| CodeExp '.' CodeExp  				{CodeClassAccess $1 $3 }
	 	| CodeExp '&' CodeExp  				{CodeBinaryOpLogicAnd $1 $3 }
	 	| CodeExp '|' CodeExp  				{CodeBinaryOpLogicOr $1 $3 }
	 	| CodeExp '^' CodeExp  				{CodeBinaryOpLogicXor $1 $3 }	
	 	| CodeExp '=' CodeExp  		        {CodeBinaryAssign $1 $3 }
	 	| CodeExp '==' CodeExp  		    {CodeBinaryEq $1 $3 }		
	 	| CodeExp '!=' CodeExp  		    {CodeBinaryNotEq $1 $3 }
	 	| CodeExp '<<' CodeExp  		    {CodeBinaryOpShiftLeft $1 $3 }		
	 	| CodeExp '>>' CodeExp  		    {CodeBinaryOpShiftRight $1 $3 }               
	 	| CodeExp  arrow2 SepList CodeExp  {CodeSequense $1 $4 }
	 	| '@' Exp '@'                       {CodePHaskellExp  $2}
	 	| CodeExp '?' CodeExp ':'CodeExp    {CodeIf $1 $3 $5}
	    | CodeExp '::' CodeExp 				{CodeStaticAccess $1 $3}
	    | '~' CodeExp 						{CodeUnaryLNot $2}
	    
	    

CodeExpList: {-empty -}    				{  []  }
			| CodeExp ',' CodeExpList  	{ $1:$3}  
            | CodeExp                   { [$1] }

HaskellExpList: {-empty -}    				{  []  }
			| Exp  HaskellExpList  	{ $1:$2}  
            | Exp                   { [$1] }             	 	

{-
data CExp =  CodeVariable String
               |CodeNumber   String
               |CodeBoolean  String
               |CodeBinaryOp CodeExp String CodeExp
               |CodeUnaryOp  String CodeExp
               |CodeStaticAccess  CodeExp CodeExp  --::
               |CodeClassAccess   CodeExp CodeExp  --.
               |CodeFunctionCall  CodeExp [CodeExp]
               |CodePHaskellExp  Exp
               |CodeIf CodeExp CodeExp CodeExp  --?:
               |CodeTemplateInst CodeExp [CodeExp]  --exp<, , ,>
-}
               

{


removeSep cs =  case span isSpace cs of
			    	(coment,rest) -> rest


filterNoSeparators::[Token]->[Token]
filterNoSeparators (TokenSep:TokenWhere:xs) = filterNoSeparators (TokenWhere:xs)
filterNoSeparators (TokenSep:TokenGuard:xs) = filterNoSeparators (TokenGuard:xs)
filterNoSeparators (x:xs)                   = x:filterNoSeparators xs
filterNoSeparators []                       = []

lexer :: String -> [Token]
lexer cs = filterNoSeparators (basic_lexer cs)


basic_lexer :: String -> [Token]
basic_lexer [] = []
basic_lexer ('-':'-':cs) = basic_lexer (lineComment cs)
basic_lexer ('{':'-':cs) = basic_lexer (blockComment cs)
basic_lexer (':':':':cs) = TokenTypeDef: basic_lexer cs
basic_lexer ('-':'>':cs) = TokenArrow:  basic_lexer cs
basic_lexer ('<':'-':cs) = TokenRArrow:  basic_lexer cs
basic_lexer ('<':'=':cs) = TokenMineq:  basic_lexer cs
basic_lexer ('|':'|':cs) = TokenOr:  basic_lexer cs
basic_lexer ('&':'&':cs) = TokenAnd:  basic_lexer cs
basic_lexer ('>':'=':cs) = TokenMajeq:  basic_lexer cs
basic_lexer ('=':'=':cs) = TokenLEq:  basic_lexer cs
basic_lexer ('!':'=':cs) = TokenNotEq:  basic_lexer cs
basic_lexer ('<':'<':cs) = TokenShiftLeft:  basic_lexer cs
basic_lexer ('>':'>':cs) = TokenShiftRight:  basic_lexer cs
basic_lexer ('!':cs) = TokenNot:  basic_lexer cs
basic_lexer (';':cs) = TokenArrow2:  basic_lexer cs
basic_lexer ('=':cs) = TokenEq : basic_lexer cs
basic_lexer ('\n':cs) = TokenSep:  basic_lexer cs
basic_lexer ('?':cs) = TokenIfCexp : basic_lexer cs
basic_lexer ('+':cs) = TokenPlus : basic_lexer cs
basic_lexer ('-':cs) = TokenMinus : basic_lexer cs
basic_lexer ('*':cs) = TokenTimes : basic_lexer cs
basic_lexer ('/':cs) = TokenDiv : basic_lexer cs
basic_lexer ('(':cs) = TokenOB : basic_lexer cs
basic_lexer (')':cs) = TokenCB : basic_lexer cs
basic_lexer ('<':cs) = TokenMin: basic_lexer cs
basic_lexer ('>':cs) = TokenMaj: basic_lexer cs
basic_lexer ('\\':cs) = TokenBackSlach: basic_lexer cs
basic_lexer ('%':cs) = TokenMod:basic_lexer cs
basic_lexer ('\'':cs) = TokenBinOp:basic_lexer cs
basic_lexer ('|':cs) = TokenGuard:basic_lexer cs
basic_lexer ('[':cs) = TokenOpenList:basic_lexer cs
basic_lexer (']':cs) = TokenCloseList:basic_lexer cs
basic_lexer (':':cs) = TokenListConstructor:basic_lexer cs
basic_lexer (',':cs) = TokenComma:basic_lexer cs     
basic_lexer ('.':cs) = TokenDot:basic_lexer cs
basic_lexer ('{':cs) = TokenOpenB:basic_lexer cs
basic_lexer ('}':cs) = TokenCloseB:basic_lexer cs
basic_lexer ('@':cs)  = TokenArroba:basic_lexer cs
basic_lexer ('&':cs)  = TokenLogirAnd:basic_lexer cs
basic_lexer ('^':cs)  = TokenLogirXor:basic_lexer cs
basic_lexer ('~':cs)  =	TokenLNot:basic_lexer cs
basic_lexer ('\"':cs) = lexString cs 
basic_lexer (c:cs) 
      | (isSpace c) && c /= '\n' = basic_lexer cs
      | isAlpha c || c== '_' = lexVar (c:cs)
      | isDigit c            = lexNum (c:cs)
      | otherwise            = basic_lexer cs 

lexString cs = TokenString str : basic_lexer (tail rest)
      				where 
      					(str,rest) = span (/='\"') cs
      					
      					


lexNum cs = TokenInt  num : basic_lexer rest
      where (num,rest) = span isDigit cs

isAlphaOrDigit char = isAlpha char || isDigit char || (char =='_')

lexVar cs =
   case span isAlphaOrDigit cs of
	 ("int",rest) -> TokenTypeInt: basic_lexer rest
	 ("bool",rest)-> TokenTypeBool: basic_lexer rest 
	 ("not",rest) -> TokenNot:  basic_lexer rest
	 ("where",rest) -> TokenWhere:  basic_lexer rest
	 ("end",rest)   -> TokenEnd:   basic_lexer rest	 
	 ("if",rest)    -> TokenIf:   basic_lexer rest
	 ("then",rest)  -> TokenThen:   basic_lexer rest
	 ("else",rest)  -> TokenElse:   basic_lexer rest
	 ("otherwise",rest)  -> TokenOtherwise:   basic_lexer rest
	 ("data",rest)  -> TokenData: basic_lexer rest
	 ("true",rest)  -> (TokenBool "true"):  basic_lexer rest
	 ("false",rest) -> (TokenBool "false"):  basic_lexer rest
	 ("True",rest)  -> (TokenBool "true"):  basic_lexer rest
	 ("False",rest) -> (TokenBool "false"):  basic_lexer rest
	 ("sizeof",rest) -> TokenSizeOf:  basic_lexer rest  
	 (var,rest)     -> TokenVar var : basic_lexer rest
          
isNotEndLine c = (c /='\n')
lineComment cs =
			   case span isNotEndLine cs of
			    	(coment,rest) ->  rest
 
blockComment ('-':'}':cs) =  cs
blockComment (c:cs) = blockComment cs
blockComment [] =  []


}
